home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / mailcrypt / mc-pgp.el.z / mc-pgp.el
Encoding:
Text File  |  1998-05-21  |  21.4 KB  |  621 lines
  1. ;; mc-pgp.el, PGP support for Mailcrypt
  2. ;; Copyright (C) 1995  Jin Choi <jin@atype.com>
  3. ;;                     Patrick LoPresti <patl@lcs.mit.edu>
  4.  
  5. ;;{{{ Licensing
  6. ;; This file is intended to be used with GNU Emacs.
  7.  
  8. ;; This program is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; This program is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  20. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21. ;;}}}
  22. (require 'mailcrypt)
  23.  
  24. (defvar mc-pgp-user-id (user-login-name)
  25.   "*PGP ID of your default identity.")
  26. (defvar mc-pgp-always-sign nil 
  27.   "*If t, always sign encrypted PGP messages, or never sign if 'never.")
  28. (defvar mc-pgp-path "pgp" "*The PGP executable.")
  29. (defvar mc-pgp-display-snarf-output nil
  30.   "*If t, pop up the PGP output window when snarfing keys.")
  31. (defvar mc-pgp-alternate-keyring nil
  32.   "*Public keyring to use instead of default.")
  33. (defvar mc-pgp-comment
  34.   (format "Processed by Mailcrypt %s, an Emacs/PGP interface" mc-version)
  35.   "*Comment field to appear in ASCII armor output.  If nil, let PGP
  36. use its default.")
  37.  
  38. (defconst mc-pgp-msg-begin-line "-----BEGIN PGP MESSAGE-----"
  39.   "Text for start of PGP message delimiter.")
  40. (defconst mc-pgp-msg-end-line "-----END PGP MESSAGE-----\n?"
  41.   "Text for end of PGP message delimiter.")
  42. (defconst mc-pgp-signed-begin-line "-----BEGIN PGP SIGNED MESSAGE-----"
  43.   "Text for start of PGP signed messages.")
  44. (defconst mc-pgp-signed-end-line "-----END PGP SIGNATURE-----"
  45.   "Text for end of PGP signed messages.")
  46. (defconst mc-pgp-key-begin-line "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
  47.   "Text for start of PGP public key.")
  48. (defconst mc-pgp-key-end-line "^-----END PGP PUBLIC KEY BLOCK-----\r?$"
  49.   "Text for end of PGP public key.")
  50. (defconst mc-pgp-error-re "^\\(ERROR:\\|WARNING:\\).*"
  51.   "Regular expression matching an error from PGP")
  52. (defconst mc-pgp-sigok-re "^.*Good signature.*"
  53.   "Regular expression matching a PGP signature validation message")
  54. (defconst mc-pgp-newkey-re "^[ \t]*\\(No\\|[0-9]+\\) +new [ku].*"
  55.   "Regular expression matching a PGP key snarf message")
  56. (defconst mc-pgp-nokey-re
  57.   "Cannot find the public key matching userid '\\(.+\\)'$"
  58.   "Regular expression matching a PGP missing-key message")
  59. (defconst mc-pgp-key-expected-re
  60.   "Key matching expected Key ID \\(\\S +\\) not found")
  61.  
  62. (defvar mc-pgp-keydir nil
  63.   "Directory in which keyrings are stored.")
  64.  
  65. (defun mc-get-pgp-keydir ()
  66.   (if (null mc-pgp-keydir)
  67.       (let ((buffer (generate-new-buffer " *mailcrypt temp*"))
  68.         (obuf (current-buffer)))
  69.     (unwind-protect
  70.         (progn
  71.           (call-process mc-pgp-path nil buffer nil "+verbose=1"
  72.                 "+language=en" "-kv" "XXXXXXXXXX")
  73.           (set-buffer buffer)
  74.           (goto-char (point-min))
  75.           (re-search-forward "^Key ring:\\s *'\\(.*\\)'")
  76.           (setq mc-pgp-keydir
  77.             (file-name-directory
  78.              (buffer-substring-no-properties
  79.               (match-beginning 1) (match-end 1)))))
  80.       (set-buffer obuf)
  81.       (kill-buffer buffer))))
  82.   mc-pgp-keydir)
  83.  
  84. (defvar mc-pgp-key-cache nil
  85.   "Association list mapping PGP IDs to canonical \"keys\".  A \"key\"
  86. is a pair (USER-ID . KEY-ID) which identifies the canonical IDs of the
  87. PGP ID.")
  88.  
  89. (defun mc-pgp-lookup-key (str)
  90.   ;; Look up the string STR in the user's secret key ring.  Return a
  91.   ;; pair of strings (USER-ID . KEY-ID) which uniquely identifies the
  92.   ;; matching key, or nil if no key matches.
  93.   (if (equal str "***** CONVENTIONAL *****") nil
  94.     (let ((keyring (concat (mc-get-pgp-keydir) "secring"))
  95.       (result (cdr-safe (assoc str mc-pgp-key-cache)))
  96.       (key-regexp
  97.        "^\\(pub\\|sec\\)\\s +[^/]+/\\(\\S *\\)\\s +\\S +\\s +\\(.*\\)$")
  98.       (obuf (current-buffer))
  99.       buffer)
  100.       (if (null result)
  101.       (unwind-protect
  102.           (progn
  103.         (setq buffer (generate-new-buffer " *mailcrypt temp"))
  104.         (call-process mc-pgp-path nil buffer nil
  105.                   "+language=en" "-kv" str keyring)
  106.         (set-buffer buffer)
  107.         (goto-char (point-min))
  108.         (if (re-search-forward key-regexp nil t)
  109.             (progn
  110.               (setq result
  111.                 (cons (buffer-substring-no-properties
  112.                    (match-beginning 3) (match-end 3))
  113.                   (concat
  114.                    "0x"
  115.                    (buffer-substring-no-properties
  116.                     (match-beginning 2) (match-end 2)))))
  117.               (setq mc-pgp-key-cache (cons (cons str result)
  118.                            mc-pgp-key-cache)))))
  119.         (if buffer (kill-buffer buffer))
  120.         (set-buffer obuf)))
  121.       (if (null result)
  122.       (error "No PGP secret key for %s" str))
  123.       result)))
  124.  
  125. (defun mc-pgp-generic-parser (result)
  126.   (let (start)
  127.     (goto-char (point-min))
  128.     (cond ((not (eq result 0))
  129.        (prog1
  130.            nil
  131.          (if (mc-message "^\aError: +Bad pass phrase\\.$" (current-buffer))
  132.          (mc-deactivate-passwd t)
  133.            (mc-message mc-pgp-error-re (current-buffer)
  134.                (format "PGP exited with status %d" result)))))
  135.       ((re-search-forward mc-pgp-nokey-re nil t)
  136.        nil)
  137.       (t
  138.        (and
  139.         (goto-char (point-min))
  140.         (re-search-forward "-----BEGIN PGP.*-----$" nil t)
  141.         (setq start (match-beginning 0))
  142.         (goto-char (point-max))
  143.         (re-search-backward "^-----END PGP.*-----\n" nil t)
  144.         (cons start (match-end 0)))))))
  145.  
  146. (defun mc-pgp-encrypt-region (recipients start end &optional id sign)
  147.   (let ((process-environment process-environment)
  148.     (buffer (get-buffer-create mc-buffer-name))
  149.     ;; Crock.  Rewrite someday.
  150.     (mc-pgp-always-sign mc-pgp-always-sign)
  151.     (obuf (current-buffer))
  152.     action msg args key passwd result pgp-id)
  153.     (setq args (list "+encrypttoself=off +verbose=1" "+batchmode"
  154.              "+language=en" "-fat"))
  155.     (setq action (if recipients "Encrypting" "Armoring"))
  156.     (setq msg (format "%s..." action))  ; May get overridden below
  157.     (if recipients (setq args (cons "-e" args)))
  158.     (if mc-pgp-comment
  159.     (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
  160.     (if mc-pgp-alternate-keyring
  161.     (setq args (append args (list (format "+pubring=%s"
  162.                           mc-pgp-alternate-keyring)))))
  163.     (if (and (not (eq mc-pgp-always-sign 'never))
  164.          (or mc-pgp-always-sign sign (y-or-n-p "Sign the message? ")))
  165.     (progn
  166.       (setq mc-pgp-always-sign t)
  167.       (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
  168.       (setq passwd
  169.         (mc-activate-passwd
  170.          (cdr key)
  171.          (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
  172.       (setq args
  173.         (nconc args (list "-s" "-u" (cdr key))))
  174.       (setenv "PGPPASSFD" "0")
  175.       (setq msg (format "%s+signing as %s ..." action (car key))))
  176.       (setq mc-pgp-always-sign 'never))
  177.  
  178.     (or key
  179.     (setq key (mc-pgp-lookup-key mc-pgp-user-id)))
  180.  
  181.     (if (and recipients mc-encrypt-for-me)
  182.     (setq recipients (cons (cdr key) recipients)))
  183.  
  184.     (setq args (append args recipients))
  185.     
  186.     (message "%s" msg)
  187.     (setq result (mc-process-region start end passwd mc-pgp-path args
  188.                     'mc-pgp-generic-parser buffer))
  189.     (save-excursion
  190.       (set-buffer buffer)
  191.       (goto-char (point-min))
  192.       (if (re-search-forward mc-pgp-nokey-re nil t)
  193.       (progn
  194.         (if result (error "This should never happen."))
  195.         (setq pgp-id (buffer-substring-no-properties
  196.               (match-beginning 1) (match-end 1)))
  197.         (if (and (not (eq mc-pgp-always-fetch 'never))
  198.              (or mc-pgp-always-fetch
  199.              (y-or-n-p
  200.               (format "Key for '%s' not found; try to fetch? "
  201.                   pgp-id))))
  202.         (progn
  203.           (mc-pgp-fetch-key (cons pgp-id nil))
  204.           (set-buffer obuf)
  205.           (mc-pgp-encrypt-region recipients start end id))
  206.           (mc-message mc-pgp-nokey-re buffer)
  207.           nil))
  208.     (if (not result)
  209.         nil
  210.       (message "%s Done." msg)
  211.       t)))))
  212.  
  213. (defun mc-pgp-decrypt-parser (result)
  214.   (goto-char (point-min))
  215.   (cond ((eq result 0)
  216.      ;; Valid signature
  217.      (re-search-forward "^Signature made.*\n")
  218.      (if (looking-at
  219.           "\a\nWARNING:  Because this public key.*\n.*\n.*\n")
  220.          (goto-char (match-end 0)))
  221.      (cons (point) (point-max)))
  222.     ((eq result 1)
  223.      (re-search-forward
  224.       "\\(\\(^File is conven.*\\)?Just a moment\\.+\\)\\|\\(^\\.\\)")
  225.      (if (eq (match-beginning 2) (match-end 2))
  226.          (if (looking-at
  227.           "\nFile has signature.*\\(\n\a.*\n\\)*\nWARNING:.*\n")
  228.          (goto-char (match-end 0)))
  229.        (if (looking-at "Pass phrase appears good\\. \\.")
  230.            (goto-char (match-end 0))))
  231.      (cons (point) (point-max)))
  232.     (t nil)))
  233.  
  234. (defun mc-pgp-decrypt-region (start end &optional id)
  235.   ;; returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if
  236.   ;; the decryption succeeded and verified is t if there was a valid signature
  237.   (let ((process-environment process-environment)
  238.     (buffer (get-buffer-create mc-buffer-name))
  239.     args key new-key passwd result pgp-id)
  240.     (undo-boundary)
  241.     (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
  242.     (setq
  243.      passwd
  244.      (if key
  245.      (mc-activate-passwd (cdr key)
  246.                  (and id
  247.                   (format "PGP passphrase for %s (%s): "
  248.                       (car key) (cdr key))))
  249.        (mc-activate-passwd id "PGP passphrase for conventional decryption: ")))
  250.     (if passwd
  251.     (setenv "PGPPASSFD" "0"))
  252.     (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
  253.     (if mc-pgp-alternate-keyring
  254.     (setq args (append args (list (format "+pubring=%s"
  255.                           mc-pgp-alternate-keyring)))))
  256.     (message "Decrypting...")
  257.     (setq result
  258.       (mc-process-region
  259.        start end passwd mc-pgp-path args 'mc-pgp-decrypt-parser buffer))
  260.     (cond
  261.      (result
  262.       (message "Decrypting... Done.")
  263.       ;; If verification failed due to missing key, offer to fetch it.
  264.       (save-excursion
  265.     (set-buffer buffer)
  266.     (goto-char (point-min))
  267.     (if (re-search-forward mc-pgp-key-expected-re nil t)
  268.         (setq pgp-id (concat "0x" (buffer-substring-no-properties
  269.                        (match-beginning 1)
  270.                        (match-end 1))))))
  271.       (if (and pgp-id
  272.            (not (eq mc-pgp-always-fetch 'never))
  273.            (or mc-pgp-always-fetch
  274.            (y-or-n-p
  275.             (format "Key %s not found; attempt to fetch? " pgp-id)))
  276.            (mc-pgp-fetch-key (cons nil pgp-id)))
  277.       (progn
  278.         (undo-start)
  279.         (undo-more 1)
  280.         (mc-pgp-decrypt-region start end id))
  281.     (mc-message mc-pgp-key-expected-re buffer)
  282.     (cons t (eq result 0))))
  283.      ;; Decryption failed; maybe we need to use a different user-id
  284.      ((save-excursion
  285.     (and
  286.      (set-buffer buffer)
  287.      (goto-char (point-min))
  288.      (re-search-forward
  289.       "^Key for user ID:.*\n.*Key ID \\([0-9A-F]+\\)" nil t)
  290.      (setq new-key
  291.            (mc-pgp-lookup-key
  292.         (concat "0x" (buffer-substring-no-properties
  293.                   (match-beginning 1)
  294.                   (match-end 1)))))
  295.      (not (and id (equal key new-key)))))
  296.       (mc-pgp-decrypt-region start end (cdr new-key)))
  297.      ;; Or maybe it is conventionally encrypted
  298.      ((save-excursion
  299.     (and
  300.      (set-buffer buffer)
  301.      (goto-char (point-min))
  302.      (re-search-forward "^File is conventionally encrypted" nil t)))
  303.       (if (null key) (mc-deactivate-passwd t))
  304.       (mc-pgp-decrypt-region start end "***** CONVENTIONAL *****"))
  305.      (t
  306.       (mc-display-buffer buffer)
  307.       (if (mc-message "^\aError: +Bad pass phrase\\.$" buffer)
  308.       (mc-deactivate-passwd t)
  309.     (mc-message mc-pgp-error-re buffer "Error decrypting buffer"))
  310.       (cons nil nil)))))
  311.  
  312. (defun mc-pgp-sign-region (start end &optional id unclear)
  313.   (let ((process-environment process-environment)
  314.     (buffer (get-buffer-create mc-buffer-name))
  315.     passwd args key)
  316.     (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
  317.     (setq passwd
  318.       (mc-activate-passwd
  319.        (cdr key)
  320.        (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
  321.     (setenv "PGPPASSFD" "0")
  322.     (setq args
  323.       (list
  324.        "-fast" "+verbose=1" "+language=en"
  325.         (format "+clearsig=%s" (if unclear "off" "on"))
  326.         "+batchmode" "-u" (cdr key)))
  327.     (if mc-pgp-comment
  328.     (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
  329.     (message "Signing as %s ..." (car key))
  330.     (if (mc-process-region start end passwd mc-pgp-path args
  331.                'mc-pgp-generic-parser buffer)
  332.     (progn
  333.       (message "Signing as %s ... Done." (car key))
  334.       t)
  335.       nil)))
  336.  
  337. (defun mc-pgp-verify-parser (result)
  338.   (cond ((eq result 0)
  339.      (mc-message mc-pgp-sigok-re (current-buffer) "Good signature")
  340.      t)
  341.     ((eq result 1)
  342.      (mc-message mc-pgp-error-re (current-buffer) "Bad signature")
  343.      nil)
  344.     (t
  345.      (mc-message mc-pgp-error-re (current-buffer)
  346.              (format "PGP exited with status %d" result))
  347.      nil)))
  348.  
  349. (defun mc-pgp-verify-region (start end &optional no-fetch)
  350.   (let ((buffer (get-buffer-create mc-buffer-name))
  351.     (obuf (current-buffer))
  352.     args pgp-id)
  353.     (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
  354.     (if mc-pgp-alternate-keyring
  355.     (setq args (append args (list (format "+pubring=%s"
  356.                           mc-pgp-alternate-keyring)))))
  357.     (message "Verifying...")
  358.     (if (mc-process-region
  359.      start end nil mc-pgp-path args 'mc-pgp-verify-parser buffer)
  360.     t
  361.       (save-excursion
  362.     (set-buffer buffer)
  363.     (goto-char (point-min))
  364.     (if (and
  365.          (not no-fetch)
  366.          (re-search-forward mc-pgp-key-expected-re nil t)
  367.          (setq pgp-id
  368.            (concat "0x" (buffer-substring-no-properties
  369.                  (match-beginning 1)
  370.                  (match-end 1))))
  371.          (not (eq mc-pgp-always-fetch 'never))
  372.          (or mc-pgp-always-fetch
  373.          (y-or-n-p
  374.           (format "Key %s not found; attempt to fetch? " pgp-id)))
  375.          (mc-pgp-fetch-key (cons nil pgp-id))
  376.          (set-buffer obuf))
  377.         (mc-pgp-verify-region start end t)
  378.       (mc-message mc-pgp-error-re buffer)
  379.       nil)))))
  380.  
  381. (defun mc-pgp-insert-public-key (&optional id)
  382.   (let ((buffer (get-buffer-create mc-buffer-name))
  383.     args)
  384.     (setq id (or id mc-pgp-user-id))
  385.     (setq args (list "+verbose=1" "+batchmode" "+language=en" "-kxaf" id))
  386.     (if mc-pgp-comment
  387.     (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
  388.     (if mc-pgp-alternate-keyring
  389.     (setq args (append args (list (format "+pubring=%s"
  390.                           mc-pgp-alternate-keyring)))))
  391.  
  392.     (if (mc-process-region (point) (point) nil mc-pgp-path
  393.                args 'mc-pgp-generic-parser buffer)
  394.     (progn
  395.       (mc-message "Key for user ID: .*" buffer)
  396.       t))))
  397.  
  398. (defun mc-pgp-snarf-parser (result)
  399.   (eq result 0))
  400.  
  401. (defun mc-pgp-snarf-keys (start end)
  402.   ;; Returns number of keys found.
  403.   (let ((buffer (get-buffer-create mc-buffer-name)) tmpstr args)
  404.     (setq args '("+verbose=1" "+batchmode" "+language=en" "-kaf"))
  405.     (if mc-pgp-alternate-keyring
  406.     (setq args (append args (list (format "+pubring=%s"
  407.                           mc-pgp-alternate-keyring)))))
  408.     (message "Snarfing...")
  409.     (if (mc-process-region start end nil mc-pgp-path args
  410.                'mc-pgp-snarf-parser buffer)
  411.     (save-excursion
  412.       (set-buffer buffer)
  413.       (goto-char (point-min))
  414.       (if (re-search-forward mc-pgp-newkey-re nil t)
  415.           (progn
  416.         (if mc-pgp-display-snarf-output (mc-display-buffer buffer))
  417.         (setq tmpstr (buffer-substring-no-properties
  418.                   (match-beginning 1) 
  419.                   (match-end 1)))
  420.         (if (equal tmpstr "No")
  421.             0
  422.           (car (read-from-string tmpstr))))))
  423.       (mc-display-buffer buffer)
  424.       (mc-message mc-pgp-error-re buffer "Error snarfing PGP keys")
  425.       0)))
  426.  
  427. ;;;###autoload
  428. (defun mc-scheme-pgp ()
  429.   (list
  430.    (cons 'encryption-func         'mc-pgp-encrypt-region)
  431.    (cons 'decryption-func        'mc-pgp-decrypt-region)
  432.    (cons 'signing-func            'mc-pgp-sign-region)
  433.    (cons 'verification-func         'mc-pgp-verify-region)
  434.    (cons 'key-insertion-func         'mc-pgp-insert-public-key)
  435.    (cons 'snarf-func            'mc-pgp-snarf-keys)
  436.    (cons 'msg-begin-line         mc-pgp-msg-begin-line)
  437.    (cons 'msg-end-line             mc-pgp-msg-end-line)
  438.    (cons 'signed-begin-line         mc-pgp-signed-begin-line)
  439.    (cons 'signed-end-line         mc-pgp-signed-end-line)
  440.    (cons 'key-begin-line         mc-pgp-key-begin-line)
  441.    (cons 'key-end-line             mc-pgp-key-end-line)
  442.    (cons 'user-id            mc-pgp-user-id)))
  443.  
  444. ;;{{{ Key fetching
  445.  
  446. (defvar mc-pgp-always-fetch nil
  447.   "*If t, always attempt to fetch missing keys, or never fetch if
  448. 'never.")
  449.  
  450. (defvar mc-pgp-keyserver-url-template
  451.   "/htbin/pks-extract-key.pl?op=get&search=%s"
  452.   "The URL to pass to the keyserver.")
  453.  
  454. (defvar mc-pgp-keyserver-address "pgp.ai.mit.edu"
  455.   "Host name of keyserver.")
  456.  
  457. (defvar mc-pgp-keyserver-port 80
  458.   "Port on which the keyserver's HTTP daemon lives.")
  459.  
  460. (defvar mc-pgp-fetch-timeout 20
  461.   "*Timeout, in seconds, for any particular key fetch operation.")
  462.  
  463. (defvar mc-pgp-fetch-keyring-list nil
  464.   "*List of strings which are filenames of public keyrings to search
  465. when fetching keys.")
  466.  
  467. (defsubst mc-pgp-buffer-get-key (buf)
  468.   "Return the first key block in BUF as a string, or nil if none found."
  469.   (save-excursion
  470.     (let (start)
  471.       (set-buffer buf)
  472.       (goto-char (point-min))
  473.       (and (re-search-forward mc-pgp-key-begin-line nil t)
  474.        (setq start (match-beginning 0))
  475.        (re-search-forward mc-pgp-key-end-line nil t)
  476.        (buffer-substring-no-properties start (match-end 0))))))
  477.  
  478. (defun mc-pgp-fetch-from-keyrings (id)
  479.   (let ((keyring-list mc-pgp-fetch-keyring-list)
  480.     buf proc key)
  481.     (unwind-protect
  482.     (progn
  483.       (message "Fetching %s from keyrings..." (or (cdr id) (car id)))
  484.       (while (and (not key) keyring-list)
  485.         (setq buf (generate-new-buffer " *mailcrypt temp*"))
  486.         (setq proc
  487.           (start-process "*PGP*" buf mc-pgp-path "-kxaf"
  488.                  "+verbose=0" "+batchmode"
  489.                  (format "+pubring=%s" (car keyring-list))
  490.                  (or (cdr id) (car id))))
  491.         ;; Because PGPPASSFD might be set
  492.         (process-send-string proc "\r\n")
  493.         (while (eq 'run (process-status proc))
  494.           (accept-process-output proc 5))
  495.         (setq key (mc-pgp-buffer-get-key buf))
  496.         (setq keyring-list (cdr keyring-list)))
  497.       key)
  498.       (if buf (kill-buffer buf))
  499.       (if (and proc (eq 'run (process-status proc)))
  500.       (interrupt-process proc)))))
  501.  
  502. (defun mc-pgp-fetch-from-http (id)
  503.   (let (buf connection)
  504.     (unwind-protect
  505.     (progn
  506.       (message "Fetching %s via HTTP to %s..."
  507.            (or (cdr id) (car id)) mc-pgp-keyserver-address)
  508.       (setq buf (generate-new-buffer " *mailcrypt temp*"))
  509.       (setq connection
  510.         (open-network-stream "*key fetch*" buf mc-pgp-keyserver-address
  511.                      mc-pgp-keyserver-port))
  512.       (process-send-string
  513.        connection
  514.        (concat "GET " (format mc-pgp-keyserver-url-template
  515.                   (or (cdr id) (car id))) "\r\n"))
  516.       (while (and (eq 'open (process-status connection))
  517.               (accept-process-output connection mc-pgp-fetch-timeout)))
  518.       (mc-pgp-buffer-get-key buf))
  519.       (if buf (kill-buffer buf))
  520.       (if connection (delete-process connection)))))
  521.  
  522. (defun mc-pgp-fetch-from-finger (id)
  523.   (let (buf connection user host)
  524.     (unwind-protect
  525.     (and (car id)
  526.          (string-match "^\\(.+\\)@\\([^@]+\\)$" (car id))
  527.          (progn
  528.            (message "Trying finger %s..." (car id))
  529.            (setq user (substring (car id)
  530.                      (match-beginning 1) (match-end 1)))
  531.            (setq host (substring (car id)
  532.                      (match-beginning 2) (match-end 2)))
  533.            (setq buf (generate-new-buffer " *mailcrypt temp*"))
  534.            (condition-case nil
  535.            (progn
  536.              (setq connection
  537.                (open-network-stream "*key fetch*" buf host 79))
  538.              (process-send-string connection
  539.                       (concat "/W " user "\r\n"))
  540.              (while
  541.              (and (eq 'open (process-status connection))
  542.                   (accept-process-output connection
  543.                              mc-pgp-fetch-timeout)))
  544.              (mc-pgp-buffer-get-key buf))
  545.          (error nil))))
  546.       (if buf (kill-buffer buf))
  547.       (if connection (delete-process connection)))))
  548.  
  549. (defvar mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings
  550.                    mc-pgp-fetch-from-finger
  551.                    mc-pgp-fetch-from-http)
  552.   "List of methods to try when attempting to fetch a key.  Each
  553. element is a function to call with an ID as argument.  See the
  554. documentation for the function mc-pgp-fetch-key for a description of
  555. the ID.")
  556.  
  557. ;;;###autoload
  558. (defun mc-pgp-fetch-key (&optional id)
  559.   "Attempt to fetch a key for addition to PGP keyring.  Interactively,
  560. prompt for string matching key to fetch.
  561.  
  562. Non-interactively, ID must be a pair.  The CAR must be a bare Email
  563. address and the CDR a keyID (with \"0x\" prefix).  Either, but not
  564. both, may be nil.
  565.  
  566. Return t if we think we were successful; nil otherwise.  Note that nil
  567. is not necessarily an error, since we may have merely fired off an Email
  568. request for the key."
  569.   (interactive)
  570.   (let ((methods mc-pgp-fetch-methods)
  571.     (process-connection-type nil) key proc buf args)
  572.     (if (null id)
  573.     (setq id (cons (read-string "Fetch key for: ") nil)))
  574.     (while (and (not key) methods)
  575.       (setq key (funcall (car methods) id))
  576.       (setq methods (cdr methods)))
  577.     (if (not (stringp key))
  578.     (progn
  579.       (message "Key not found.")
  580.       nil)
  581.       ;; Maybe I'll do this right someday.
  582.       (unwind-protect
  583.       (save-window-excursion
  584.         (setq buf (generate-new-buffer " *PGP Key Info*"))
  585.         (pop-to-buffer buf)
  586.         (if (< (window-height) (/ (frame-height) 2))
  587.         (enlarge-window (- (/ (frame-height) 2)
  588.                    (window-height))))
  589.         (setq args '("-f" "+verbose=0" "+batchmode"))
  590.         (if mc-pgp-alternate-keyring
  591.         (setq args
  592.               (append args (list (format "+pubring=%s"
  593.                          mc-pgp-alternate-keyring)))))
  594.  
  595.         (setq proc (apply 'start-process "*PGP*" buf mc-pgp-path args))
  596.         ;; Because PGPPASSFD might be set
  597.         (process-send-string proc "\r\n")
  598.         (process-send-string proc key)
  599.         (process-send-string proc "\r\n")
  600.         (process-send-eof proc)
  601.         (set-buffer buf)
  602.         (while (eq 'run (process-status proc))
  603.           (accept-process-output proc 5)
  604.           (goto-char (point-min)))
  605.         (if (y-or-n-p "Add this key to keyring? ")
  606.         (progn
  607.           (setq args (append args '("-ka")))
  608.           (setq proc
  609.             (apply 'start-process "*PGP*" buf mc-pgp-path args))
  610.           ;; Because PGPPASSFD might be set
  611.           (process-send-string proc "\r\n")
  612.           (process-send-string proc key)
  613.           (process-send-string proc "\r\n")
  614.           (process-send-eof proc)
  615.           (while (eq 'run (process-status proc))
  616.             (accept-process-output proc 5))
  617.           t)))
  618.     (if buf (kill-buffer buf))))))
  619.  
  620. ;;}}}
  621.